#!bin/perl
################################################################################
#Code Convention Checker for Perl modules
#Convention: 	1. Code column length no longer than 80 characters;
#				2. No cyclic dependency with "use" directive.
################################################################################
# 	#######	######	###	###########	##################		########		#######	################	###

use Getopt::Std;
use Cwd;
use File::Spec;
use PPI;
use Data::Dumper;
use vars qw ( %opt );
use constant {
    COLUMN_WIDTH_MAX => 80,
    TABSIZE          => 4
};

#
# Usage message
#
sub _usage() {
    print STDERR << "END";
Code Convention Checker for Perl modules.

usage: $0 [-h] [-d dir]

-d dir	: working directory, default will be the current working directory
-h	: display this message
END
    exit;
}

#
# configure and handle options
#
sub _init_opts() {
    my $config = 'hd:';
    getopts( $config, \%opt );
    _usage() if $opt{h};
}

# main routine
_init_opts();

my $dir = $opt{d};

die "Path not exist: $dir!\n" unless -e $dir;

unless ( File::Spec->file_name_is_absolute( $dir ) ){
	my $cwd = Cwd->cwd();
	$dir = File::Spec->catdir( ( File::Spec->splitdir($cwd),
		File::Spec->splitdir($dir) ) );
}

# default dir is current working dir
$dir = Cwd->cwd() unless ($dir);
print "#" x 80 . "\n";
print "Inspecting Directory:$dir\n";
print "#" x 80 . "\n\n";
$dir = File::Spec->canonpath($dir);
chdir $dir or die "Cannot change to dir $dir!\n";

# get only files ending with .pm or .pl, including hidden files
my ( @files, @dirs );
push @dirs, $dir;

while (@dirs) {
    my $dir = shift @dirs;
    opendir DH, $dir or die "Cannot open dir $dir!\n";
    foreach my $file ( readdir DH ) {
        my $sub = File::Spec->catfile( ($dir), $file )
          unless $file =~ /^\.{1,2}$/;
        if ( -d $sub ) {
            push @dirs, $sub;
        }
        elsif ( $file =~ m/\.pm$|\.pl$/i ) {
            push @files, $sub;
        }
    }
    closedir DH;
}

# print file list;
print "File list:\n" . ( join "\n", @files ) . "\n";
print "#" x 80 . "\n\n";
print "Source code length violation verification...\n\n";

my $lengthFlag = 0;
for my $file (@files) {
	open HANDLE, $file or ( print "Cannot read file: $file!" && next );
    $. = 0;
    while (<HANDLE>) {
        chomp;
        my $len      = length;
        my $tabIndex = 0;
        my $tabCount = () = m/\t/g;    # count match instances
        my $lenAugment = 0;   # used to temporarily record actual length with \t

        for ( my $i = 0 ; $i < $tabCount ; $i++ ) {
            $tabIndex = index( $_, "\t", $tabIndex );
            $lenAugment +=
              TABSIZE - ( ( $tabIndex + $lenAugment ) % TABSIZE ) - 1;
            $tabIndex++;
        }
        $len += $lenAugment;

        if ( $len > COLUMN_WIDTH_MAX ) {
            $lengthFlag = 1;
            print "File: $file\nColumn width:$len, line:$.. \n\n";
        }
    }
    close HANDLE;
}

print "No column length violation." unless $lengthFlag;

print "#" x 80 . "\n\n";
print "Source code library cyclic dependency detection...\n\n";

my %dependencies;
for my $file (@files) {
    print "Cannot read file: $file!" && next if !-r $file;

    # parse the script
    my $document = PPI::Document->new($file);

    unless ($document){
    	print "cannot parse:$file\n";
		next;
    }

    # find all includes
    my $uses = $document->find('PPI::Statement::Include');
    foreach ( @{$uses} ) {
		next if $_->type() eq 'no';

		if ( /\(\s*\)\s*;\s*$/ ){
			next;
		}

        my $module = $_->module();
		my @parseDir = split /::/, $module;

        # take basename from the end of the list
        my $basename = pop @parseDir;

        # import the base directory
        my $libDir = $dir;

        # reconstruct the path
        my @libDir = File::Spec->splitdir($libDir);
        my $dependee = File::Spec->catfile( ( @libDir, @parseDir ), $basename );

        # globs perl module extention combinations
	    my $exists = 0;
		unless ( -e $dependee && $dependee =~ /\.p[ml]/i ) {
 	       	my @extensions = qw /pl PL pm PM Pl Pm pL pM/;
 	       	for my $ext (@extensions) {
 	          	my $combination = $dependee . ".$ext";
  	         	if ( -e $combination ) {
   		            $dependee = $combination;
    	            $exists   = 1;
                	last;
            	}
        	}
		}

        # If not found here, then let perl itself issue the warning.
        #print "Lib module not found: $dependee!" unless $exists;

        # now $dependee contains module name
        #print "$file->${dependee}\n";
        if ($exists) {
            $ref = $dependencies{$file};
            if ( @$ref == 0 ) {
                $dependencies{$file} = [$dependee];
            }
            else {
                push @{ $dependencies{$file} }, $dependee;
            }
        }
    }    # end foreach uses

}    # end for each file

#print Dumper(%dependencies);

################################################################################
# Detect Cycles in Dependency, BFS over every node, if found a back edge then a
# loop exists
################################################################################

use constant {
    UNVISITED => 0,
    FINISHED  => 1,
    STACK     => -1
};

my %statusClean;
for my $key ( keys %dependencies ) {
    $statusClean{$key} = UNVISITED;
    my @list = @{ $dependencies{$key} };
    $statusClean{$_} = UNVISITED for @list;
}

#print Dumper(\%statusClean);

my %cycles;

for my $start ( keys %dependencies ) {
    # start dfs from every node
    # find back edge
    my %status = %statusClean;
    my @trace  = ($start);
    $status{$start} = STACK;

    # use stack instead recursion, need info from the stack
    my @path = ();
    while (@trace) {
        my $key = $trace[ @trace - 1 ];
        push @path, $key;
        if ( @{ $dependencies{$key} } == 0 ) {
            $status{$key} = FINISHED;
            pop @path;
            pop @trace;
        }
        else {
            my $finishFlag = 1;
            for ( @{ $dependencies{$key} } ) {
                if ( $status{$_} == STACK ) {

                    # found back edge
                    #print "list:  @{ $dependencies{$key} }\n";
                    #print "trace: @trace\n\tback:$key -> $_\n";
                    my $flag = 0, my $start = $_;
                    my %slice;
                    for (@path) {
                        $flag = 1 if $_ eq $start;
                        $slice{$_} = 0 if $flag;
                        last if $_ eq $key;
                    }

                    #print "$key -> $_\n" if @slice == 0;
                    my $str = join " ", sort keys %slice;

                    #print "cycle: $str\n\n";
                    $cycles{$str} = 0 if $str;
                }
                elsif ( $status{$_} == UNVISITED ) {
                    $finishFlag = 0;
                    push @trace, $_;
                    $status{$_} = STACK;
                }    # only finished left
            }
            pop @path if $finishedFlag;
            my $finished = pop @trace if $finishFlag;
            $status{$finished} = FINISHED;
        }
    }
}

if (%cycles) {
	print "Circle: $_\n\n" for keys %cycles;
}
else {
	print "No cyclic dependency detected!\n";
}
